home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 June / Chip_2002-06_cd1.bin / zkuste / delphi / kolekce / d6 / rxlibsetup.exe / {app} / units / EXCPTDLG.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  2002-02-19  |  9.9 KB  |  376 lines
  1. {*******************************************************}
  2. {                                                       }
  3. {         Delphi VCL Extensions (RX)                    }
  4. {                                                       }
  5. {         Copyright (c) 2001,2002 SGB Software          }
  6. {         Copyright (c) 1997, 1998 Fedor Koshevnikov,   }
  7. {                        Igor Pavluk and Serge Korolev  }
  8. {                                                       }
  9. {*******************************************************}
  10.  
  11. unit ExcptDlg;
  12.  
  13. {$I RX.INC}
  14.  
  15. interface
  16.  
  17. uses
  18.   SysUtils, Messages, Classes, Graphics, Controls, Forms, Dialogs,
  19.   StdCtrls, ExtCtrls, RXCtrls;
  20.  
  21. type
  22.   TErrorEvent = procedure (Error: Exception; var Msg: string) of object;
  23.  
  24.   TRxErrorDialog = class(TForm)
  25.     BasicPanel: TPanel;
  26.     ErrorText: TLabel;
  27.     IconPanel: TPanel;
  28.     IconImage: TImage;
  29.     TopPanel: TPanel;
  30.     RightPanel: TPanel;
  31.     DetailsPanel: TPanel;
  32.     MessageText: TMemo;
  33.     ErrorAddress: TEdit;
  34.     ErrorType: TEdit;
  35.     ButtonPanel: TPanel;
  36.     DetailsBtn: TButton;
  37.     OKBtn: TButton;
  38.     AddrLabel: TRxLabel;
  39.     TypeLabel: TRxLabel;
  40.     BottomPanel: TPanel;
  41.     procedure FormCreate(Sender: TObject);
  42.     procedure FormDestroy(Sender: TObject);
  43.     procedure FormShow(Sender: TObject);
  44.     procedure DetailsBtnClick(Sender: TObject);
  45.     procedure ErrorInfo(var LogicalAddress: Pointer; var ModuleName: string);
  46.     procedure FormKeyUp(Sender: TObject; var Key: Word;
  47.       Shift: TShiftState);
  48.   private
  49.     Details: Boolean;
  50.     DetailsHeight: Integer;
  51.     ExceptObj: Exception;
  52.     FPrevOnException: TExceptionEvent;
  53.     FOnErrorMsg: TErrorEvent;
  54. {$IFDEF WIN32}
  55.     FHelpFile: string;
  56. {$ENDIF}
  57.     procedure GetErrorMsg(var Msg: string);
  58.     procedure ShowError;
  59.     procedure SetShowDetails(Value: Boolean);
  60. {$IFDEF WIN32}
  61.     procedure WMHelp(var Message: TWMHelp); message WM_HELP;
  62. {$ENDIF}
  63.   public
  64.     procedure ShowException(Sender: TObject; E: Exception);
  65.     property OnErrorMsg: TErrorEvent read FOnErrorMsg write FOnErrorMsg;
  66.   end;
  67.  
  68. const
  69.   ErrorDlgHelpCtx: THelpContext = 0;
  70.  
  71. var
  72.   RxErrorDialog: TRxErrorDialog;
  73.  
  74. procedure RxErrorIntercept;
  75.  
  76. implementation
  77.  
  78. uses
  79. {$IFDEF WIN32}
  80.   Windows, {$IFDEF RX_D3} ComObj, {$ELSE} OleAuto, {$ENDIF RX_D3}
  81. {$ELSE WIN32}
  82.   WinProcs, WinTypes, ToolHelp, Str16,
  83. {$ENDIF WIN32}
  84.   Consts, RxCConst, rxStrUtils, VCLUtils;
  85.  
  86. {$R *.DFM}
  87.  
  88. {$IFDEF RX_D3}
  89. resourcestring
  90. {$ELSE}
  91. const
  92. {$ENDIF}
  93.   SCodeError = '%s.'#13#10'Error Code: %.8x (%1:d).';
  94.   SModuleError = 'Exception in module %s.'#13#10'%s';
  95.  
  96. const
  97.   CRLF = #13#10;
  98.  
  99. procedure RxErrorIntercept;
  100. begin
  101.   if RxErrorDialog <> nil then RxErrorDialog.Free;
  102.   RxErrorDialog := TRxErrorDialog.Create(Application);
  103. end;
  104.  
  105. { TRxErrorDialog }
  106.  
  107. procedure TRxErrorDialog.ShowException(Sender: TObject; E: Exception);
  108. begin
  109.   Screen.Cursor := crDefault;
  110.   Application.NormalizeTopMosts;
  111.   try
  112.     if Assigned(FPrevOnException) then FPrevOnException(Sender, E)
  113.     else if (ExceptObj = nil) and not Application.Terminated then begin
  114.       ExceptObj := E;
  115.       try
  116.         ShowModal;
  117.       finally
  118.         ExceptObj := nil;
  119.       end;
  120.     end
  121.     else begin
  122.       if NewStyleControls then Application.ShowException(E)
  123.       else MessageDlg(E.Message + '.', mtError, [mbOk], 0);
  124.     end;
  125.   except
  126.     { ignore any exceptions }
  127.   end;
  128.   Application.RestoreTopMosts;
  129. end;
  130.  
  131. {$IFDEF WIN32}
  132.  
  133. function ConvertAddr(Address: Pointer): Pointer; assembler;
  134. asm
  135.         TEST    EAX,EAX
  136.         JE      @@1
  137.         SUB     EAX, $1000
  138. @@1:
  139. end;
  140.  
  141. procedure TRxErrorDialog.ErrorInfo(var LogicalAddress: Pointer;
  142.   var ModuleName: string);
  143. var
  144.   Info: TMemoryBasicInformation;
  145.   Temp, ModName: array[0..MAX_PATH] of Char;
  146. begin
  147.   VirtualQuery(ExceptAddr, Info, SizeOf(Info));
  148.   if (Info.State <> MEM_COMMIT) or
  149.     (GetModuleFilename(THandle(Info.AllocationBase), Temp,
  150.     SizeOf(Temp)) = 0) then
  151.   begin
  152.     GetModuleFileName(HInstance, Temp, SizeOf(Temp));
  153.     LogicalAddress := ConvertAddr(LogicalAddress);
  154.   end
  155.   else Integer(LogicalAddress) := Integer(LogicalAddress) -
  156.     Integer(Info.AllocationBase);
  157. {$IFDEF RX_D3}
  158.   StrLCopy(ModName, AnsiStrRScan(Temp, '\') + 1, SizeOf(ModName) - 1);
  159. {$ELSE}
  160.   StrLCopy(ModName, StrRScan(Temp, '\') + 1, SizeOf(ModName) - 1);
  161. {$ENDIF}
  162.   ModuleName := StrPas(ModName);
  163. end;
  164.  
  165. {$ELSE}
  166.  
  167. function ConvertAddr(Address: Pointer): Pointer; assembler;
  168. asm
  169.         MOV     AX,Address.Word[0]
  170.         MOV     DX,Address.Word[2]
  171.         MOV     CX,DX
  172.         OR      CX,AX
  173.         JE      @@1
  174.         CMP     DX,0FFFFH
  175.         JE      @@1
  176.         MOV     ES,DX
  177.         MOV     DX,ES:Word[0]
  178. @@1:
  179. end;
  180.  
  181. procedure TRxErrorDialog.ErrorInfo(var LogicalAddress: Pointer;
  182.   var ModuleName: string);
  183. var
  184.   GlobalEntry: TGlobalEntry;
  185.   hMod: THandle;
  186.   ModName: array[0..15] of Char;
  187.   Buffer: array[0..255] of Char;
  188. begin
  189.   GlobalEntry.dwSize := SizeOf(GlobalEntry);
  190.   if GlobalEntryHandle(@GlobalEntry, THandle(PtrRec(LogicalAddress).Seg)) then
  191.     with GlobalEntry do begin
  192.       hMod := hOwner;
  193.       if wType in [GT_CODE, GT_DATA, GT_DGROUP] then
  194.         PtrRec(LogicalAddress).Seg := wData;
  195.     end
  196.     else LogicalAddress := ConvertAddr(LogicalAddress);
  197.   GetModuleFileName(hMod, Buffer, SizeOf(Buffer));
  198.   StrLCopy(ModName, StrRScan(Buffer, '\') + 1, SizeOf(ModName) - 1);
  199.   ModuleName := StrPas(ModName);
  200. end;
  201.  
  202. {$ENDIF}
  203.  
  204. procedure TRxErrorDialog.ShowError;
  205. var
  206.   S, ModuleName: string;
  207.   P: Pointer;
  208. begin
  209.   P := ExceptAddr;
  210.   ModuleName := '';
  211.   ErrorInfo(P, ModuleName);
  212.   AddrLabel.Enabled := (P <> nil);
  213.   ErrorAddress.Text := Format('%p', [ExceptAddr]);
  214.   ErrorType.Text := ExceptObj.ClassName;
  215.   TypeLabel.Enabled := ErrorType.Text <> '';
  216.   S := Trim(ExceptObj.Message);
  217.   if Pos(CRLF, S) = 0 then
  218.     S := ReplaceStr(S, #10, CRLF);
  219.   if ExceptObj is EInOutError then
  220.     S := Format(SCodeError, [S, EInOutError(ExceptObj).ErrorCode])
  221. {$IFDEF WIN32}
  222.   else if ExceptObj is EOleException then begin
  223.     with EOleException(ExceptObj) do
  224.       if (Source <> '') and (AnsiCompareText(S, Trim(Source)) <> 0) then
  225.         S := S + CRLF + Trim(Source);
  226.     S := Format(SCodeError, [S, EOleException(ExceptObj).ErrorCode])
  227.   end
  228.   else if ExceptObj is EOleSysError then
  229.     S := Format(SCodeError, [S, EOleSysError(ExceptObj).ErrorCode])
  230.   else if ExceptObj is EExternalException then
  231.     S := Format(SCodeError, [S,
  232.       EExternalException(ExceptObj).ExceptionRecord^.ExceptionCode])
  233. {$ENDIF}
  234. {$IFDEF RX_D3}
  235.   else if ExceptObj is EOSError then
  236.     S := Format(SCodeError, [S, EOSError(ExceptObj).ErrorCode])
  237. {$ENDIF}
  238.   else S := S + '.';
  239.   MessageText.Text := Format(SModuleError, [ModuleName, S]);
  240. end;
  241.  
  242. procedure TRxErrorDialog.SetShowDetails(Value: Boolean);
  243. begin
  244.   DisableAlign;
  245.   try
  246.     if Value then begin
  247.       DetailsPanel.Height := DetailsHeight;
  248.       ClientHeight := DetailsPanel.Height + BasicPanel.Height;
  249.       DetailsBtn.Caption := '<< &' + LoadStr(SDetails);
  250.       ShowError;
  251.     end
  252.     else begin
  253.       ClientHeight := BasicPanel.Height;
  254.       DetailsPanel.Height := 0;
  255.       DetailsBtn.Caption := '&' + LoadStr(SDetails) + ' >>';
  256.     end;
  257.     DetailsPanel.Enabled := Value;
  258.     Details := Value;
  259.   finally
  260.     EnableAlign;
  261.   end;
  262. end;
  263.  
  264. procedure TRxErrorDialog.GetErrorMsg(var Msg: string);
  265. var
  266.   I: Integer;
  267. begin
  268.   I := Pos(CRLF, Msg);
  269.   if I > 0 then System.Delete(Msg, I, MaxInt);
  270.   if Assigned(FOnErrorMsg) then
  271.     try
  272.       FOnErrorMsg(ExceptObj, Msg);
  273.     except
  274.     end;
  275. end;
  276.  
  277. {$IFDEF WIN32}
  278. procedure TRxErrorDialog.WMHelp(var Message: TWMHelp);
  279. var
  280.   AppHelpFile: string;
  281. begin
  282.   AppHelpFile := Application.HelpFile;
  283.   try
  284.     if FHelpFile <> '' then
  285.       Application.HelpFile := FHelpFile;
  286.     inherited;
  287.   finally
  288.     Application.HelpFile := AppHelpFile;
  289.   end;
  290. end;
  291. {$ENDIF}
  292.  
  293. procedure TRxErrorDialog.FormCreate(Sender: TObject);
  294. begin
  295. {$IFDEF WIN32}
  296.   BorderIcons := [biSystemMenu, biHelp];
  297. {$ELSE}
  298.   BorderIcons := [];
  299. {$ENDIF}
  300.   DetailsHeight := DetailsPanel.Height;
  301.   Icon.Handle := LoadIcon(0, IDI_HAND);
  302.   IconImage.Picture.Icon := Icon;
  303.   { Load string resources }
  304.   Caption := ResStr(SMsgDlgError);
  305.   OKBtn.Caption := ResStr(SOKButton);
  306.   { Set exception handler }
  307.   FPrevOnException := Application.OnException;
  308.   Application.OnException := ShowException;
  309. end;
  310.  
  311. procedure TRxErrorDialog.FormDestroy(Sender: TObject);
  312. begin
  313.   Application.OnException := FPrevOnException;
  314. end;
  315.  
  316. procedure TRxErrorDialog.FormShow(Sender: TObject);
  317. var
  318.   S: string;
  319. {$IFDEF WIN32}
  320.   ExStyle: Longint;
  321. {$ENDIF}
  322. begin
  323.   if ExceptObj.HelpContext <> 0 then
  324.     HelpContext := ExceptObj.HelpContext
  325.   else HelpContext := ErrorDlgHelpCtx;
  326. {$IFDEF WIN32}
  327.   if ExceptObj is EOleException then
  328.     FHelpFile := EOleException(ExceptObj).HelpFile
  329.   else FHelpFile := '';
  330.   ExStyle := GetWindowLong(Handle, GWL_EXSTYLE);
  331.   if (HelpContext <> 0) then
  332.     ExStyle := ExStyle or WS_EX_CONTEXTHELP
  333.   else
  334.     ExStyle := ExStyle and not WS_EX_CONTEXTHELP;
  335.   SetWindowLong(Handle, GWL_EXSTYLE, ExStyle);
  336. {$ENDIF}
  337.   S := Trim(ExceptObj.Message) + '.';
  338.   GetErrorMsg(S);
  339.   ErrorText.Caption := S;
  340.   SetShowDetails(False);
  341.   DetailsBtn.Enabled := True;
  342. end;
  343.  
  344. procedure TRxErrorDialog.DetailsBtnClick(Sender: TObject);
  345. begin
  346.   SetShowDetails(not Details);
  347. end;
  348.  
  349. procedure TRxErrorDialog.FormKeyUp(Sender: TObject; var Key: Word;
  350.   Shift: TShiftState);
  351. {$IFDEF WIN32}
  352. var
  353.   Info: THelpInfo;
  354. {$ENDIF}
  355. begin
  356.   if (Key = VK_F1) and (HelpContext <> 0) then begin
  357. {$IFDEF WIN32}
  358.     with Info do begin
  359.       cbSize := SizeOf(THelpInfo);
  360.       iContextType := HELPINFO_WINDOW;
  361.       iCtrlId := 0;
  362.       hItemHandle := Handle;
  363.       dwContextId := HelpContext;
  364.       GetCursorPos(MousePos);
  365.     end;
  366.     Perform(WM_HELP, 0, Longint(@Info));
  367. {$ELSE}
  368.     Application.HelpContext(HelpContext);
  369. {$ENDIF}
  370.   end;
  371. end;
  372.  
  373. initialization
  374.   RxErrorDialog := nil;
  375. end.
  376.